perm filename STRSER[S,AIL]19 blob
sn#187879 filedate 1975-11-23 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00028 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002
C00005 00003 HISTORY
C00010 00004 Discussion
C00013 00005 COMPIL(CAT,<CAT,CATCHR,CHRCAT,CHRCHR,CAT.RV>
C00021 00006 COMPIL(PTC,<PUTCH>,<GOGTAB,STRNGC,INSET>,<PUTCH -- PUT 1 CHARACTER ROUT>)
C00023 00007 COMPIL(PNT,<POINT,BBPP.>,<GOGTAB,X22,X44>,<POINT, BBPP.>)
C00024 00008 COMPIL(CVF,<CVF,CVG,CVE>
C00028 00009 CVF,CVE,CVG CONTD.
C00031 00010 CVF,CVG,CVE CONTD.
C00033 00011 CVF,CVG,CVE CONTD.
C00035 00012 CVF,CVG,CVE CONTD.
C00037 00013 COMPIL(SUB,<SUBST,SUBSR>,<SAVE,RESTR,X22,.SKIP.,GOGTAB>,<SUBSTRING ROUTINES>)
C00042 00014 COMPIL(EQU,<EQU>,<X44>,<EQU>)
C00044 00015 COMPIL(CVD,<CVD,CVO>,<SAVE,RESTR,X11,X22>,<CVD AND CVO ROUTINES>)
C00046 00016 COMPIL(CVS,<GETFORMAT,SETFORMAT,CVS,CVOS>
C00051 00017 COMPIL(SCN,<SCAN,BKTCHK>,<INSET,SAVE,RESTR,X44,STRNGC,BRKMSK,CORGET>,<SCAN ROUTINE>)
C00061 00018 COMPIL(CVC,<CVSIX,CVASC,CVSTR,CVXSTR,CV6STR,CVASTR>,<SAVE,RESTR,X11,X22,INSET,STRNGC,FLSCAN>
C00067 00019 COMPIL(CVL,<CVFIL>,<SAVE,RESTR,X22,X33,FILNAM,.SKIP.>,<CVFIL>)
C00069 00020 DSCR BREAKSET(TABLE #,"STRING",WAY)
C00074 00021 Setbreak
C00076 00022 Stdbrk
C00083 00023 $print
C00090 00024 DSCR PRINT routines
C00097 00025 DSCR $PRSTR -- final string printer
C00099 00026 DSCR
C00102 00027 DSCR Utility routines for PRINT statement.
C00109 00028 ENDCOM(PRN)
C00110 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000060 ⊗;
COMMENT ⊗
VERSION 17-1(48) 11-13-74 BY JFR GETBREAK BUG P.21
VERSION 17-1(47) 11-7-74 BY RHT FEAT %BW% CV6STR
VERSION 17-1(46) 11-2-74 BY JFR MODS TO HANDLE BREAKTABLE 0(P.16)
VERSION 17-1(45) 10-26-74 BY JFR GETBREAK
VERSION 17-1(44) 10-26-74 BY JFR BUG #TP GETBREAK FIXES
VERSION 17-1(43) 10-14-74 BY JFR CHECK FOR HACK'S--NONE FOUND
VERSION 17-1(42) 10-13-74 BY JFR FIX MINOR LOSSAGE IN SCAN
VERSION 17-1(41) 10-13-74 BY
VERSION 17-1(40) 10-11-74 BY JFR CORRECT TYPOS %BS%
VERSION 17-1(39) 10-11-74 BY JFR INSTALL GETBREAK, RELBREAK
VERSION 17-1(38) 10-11-74
VERSION 17-1(37) 10-11-74 BY JFR BETTER ERROR TRACING FOR %BS% BKTCHK
VERSION 17-1(36) 10-11-74 BY JFR FEAT %BS% (SECOND HALF) NEW WAY TO DO BREAK TABLES
VERSION 17-1(35) 10-10-74 BY JFR FEAT %BS% (FIRST HALF) NEW WAY TO DO BREAK TABLES
VERSION 17-1(34) 10-10-74
VERSION 17-1(33) 10-10-74
VERSION 17-1(32) 10-10-74
VERSION 17-1(31) 10-10-74
VERSION 17-1(30) 10-10-74
VERSION 17-1(29) 9-16-74 BY RHT BUG #TH# OVERFLOW IN SCAN
VERSION 17-1(28) 9-8-74 BY RHT BUG #TF# NEW SCAN LOSING WHEN NO BRK CHR
VERSION 17-1(27) 7-29-74 BY RHT BUG #SW# NEW SCAN PROBLEM
VERSION 17-1(26) 7-19-74 BY RHT FEAT %BK% MAKE SCAN BETTER FOR NON-OMIT CASE
VERSION 17-1(25) 5-30-74 BY RHT FIX UP SOME COMPILS
VERSION 17-1(24) 5-29-74 BY RHT FIX STDBRK
VERSION 17-1(23) 5-25-74 BY RLS EDIT
VERSION 17-1(22) 5-25-74 BY rls edit
VERSION 17-1(21) 5-25-74 BY rls edit
VERSION 17-1(20) 5-25-74
VERSION 17-1(19) 5-25-74 BY RLS EDIT
VERSION 17-1(18) 5-24-74 BY RLS EDIT
VERSION 17-1(17) 5-24-74 BY RLS MAKE STDBRK SYSTEM INDEPENDENT
VERSION 17-1(16) 5-24-74
VERSION 17-1(15) 5-24-74 BY rht move some routines over from ioser
VERSION 17-1(14) 5-24-74
VERSION 17-1(13) 5-24-74
VERSION 17-1(12) 5-24-74
VERSION 17-1(11) 5-24-74
VERSION 17-1(10) 5-24-74
VERSION 17-1(9) 5-24-74
VERSION 17-1(8) 5-24-74
VERSION 17-1(7) 1-13-74 BY JRL BUG QI CVO DIDN'T WORK WITH INTERRUPTS ENABLED
VERSION 17-1(6) 1-13-74
VERSION 17-1(5) 12-14-73 BY RFS BUG #QB# MAKE CVG DO LARGEST NEG RIGHT
VERSION 17-1(4) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(3) 11-28-73 BY RLS BUG #PG# CVS OF '400000000000
VERSION 17-1(2) 11-28-73
VERSION 17-1(1) 11-25-73 BY RHT BUG #LA# MAKE CVSIX HONEST
VERSION 17-1(14) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(13) 3-18-73 BY RHT PROTECT RPH FROM USERERR
VERSION 16-2(12) 5-11-72 BY DCS BUG #GY# BE SURE ALIGNED IF SGLIGN & ALREDY CATED
VERSION 15-2(6-11) 5-11-72
VERSION 15-2(5) 2-8-72 BY DCS BUG #GL# -- CANCEL SAME -- COULDN'T GET RIGHT
VERSION 15-2(4) 2-6-72 BY DCS BUG #GL# CVF, CVG, CVE DON'T PUT OUT EXTRA SPACE WHEN NON-NEGATIVE
VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# OPTIMIZE CAT, REMOVE TOPSTR
VERSION 15-2(2) 12-21-71 BY DCS BUG #FS# REMOVE SAILRUN CONDITIONAL
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
SUBTTL Discussion
LSTON (STRSER)
DSCR BEGIN STRSER
⊗
IFN ALWAYS,<BEGIN STRSER>
DSCR STRSER DISCUSSION
⊗
Comment ⊗ These routines manipulate entities known to
SAIL/GOGOL users as STRINGS. A string is described by
a two-word string descriptor with the following format:
WD1: string no,,# of characters
WD2: byte pointer to string
String no. is incremented whenever a new string is created at
the top of string space. (SUBSTR does not increment it). An
ILDB on WD2 gets the first character of the string.
All parameters necessary for string operations are in the user's
parameter table (GOGTAB pnts at it):
TOPBYTE: byte pointer to next available character
REMCHR: negative count of free characters remaining
ST: addr of first string space word
STTOP: addr of last word.
STRNGC is the compacting string garbage collector, called when not
enough space remains. The number of characters desired by the
operation detecting the lack is in register A on entry.
Strings are concatenated by copying both operands to the top
of string space (or only the 2nd if the first is already
on top), and creating a descriptor for the new string.
SUBSTR operations simply create new descriptors.
GETCH and PUTCH handle numeric to string conversions (vice-versa)
⊗
COMPIL(CAT,<CAT,CATCHR,CHRCAT,CHRCHR,CAT.RV>
,<SAVE,RESTR,X22,X33,STRNGC,INSET,GOGTAB,CONFIG,PUTCH>
,<CAT -- CONCATENATION ROUTINE>)
;;#GI# DCS 2-5-72 OPTIMIZE CAT SOME MORE, REMOVE TOPSTR
DSCR "STRING"←CAT("STR1","STR2");
CAL SAIL
DES CALL GENERATED BY COMPILER FOR & OPERATOR
⊗
DEFINE CANON (ADR,AC)<
LDB TEMP,[POINT 3,ADR,5] ;4,5,6,7,0,1 FROM POSITION
IMULI AC,5 ;ADDR IN CHARS
ADD AC,BPTBL(TEMP) ;0,1,2,3,4,5 EXTRA CHARS
>
;CAT'S MAP TABLE
BPTBL: 4
5
0
0
0
1
2
3 ;MAP
HERE (CAT.RV)
POP SP,TEMP ;ARGUMENTS ARE IN REVERSE ORDER,
POP SP,LPSA ; PUT THEM RIGHT
PUSH SP,-1(SP)
PUSH SP,-1(SP)
MOVEM LPSA,-3(SP)
MOVEM TEMP,-2(SP)
HERE (CAT)
MOVE USER,GOGTAB
POP P,UUO1(USER) ;SAVE FOR STRNGC ERR MESSAGE
MOVEI TEMP,-1 ;FOR TESTING LENGTHS
TDNN TEMP,-3(SP) ;FIRST STRING NULL?
JRST RETSEC ;YES, RETURN SECOND STRING
TDNN TEMP,-1(SP) ;SECOND STRING NULL?
JRST RETFRS ;YES, RETURN FIRST STRING
CATGO: MOVEI TEMP,RACS(USER)
BLT TEMP,RACS+3(USER)
MOVEM RF,RACS+RF(USER) ;SAVE F-REGISTER
CATGO1: HRRZ B,-2(SP) ;ADDR WORD OF FIRST STRING
MOVE LPSA,B
CANON (<-2(SP)>,LPSA) ;COMPUTE CANONICAL FORM
HRRZ A,-3(SP) ;#CHARS IN FIRST
ADD LPSA,A ;+#CHARS IN FIRST
HRRZ C,(SP) ;2D ADDRESS
CAMGE C,B ;IS IT POSSIBLE THEY ARE ALREADY CAT?
JRST CAT3 ;NO
CANON (<(SP)>,C) ;GET CANONICAL FORM OF 2D
CAMN C,LPSA ;SAME?
JRST ADJRET ;YES, RETURN ADJUSTED POINTER
CAT3: HRRZ C,TOPBYTE(USER) ;TRY SAME TRICK WITH THIS GUY
CANON (<TOPBYTE(USER)>,C)
CAMN C,LPSA ;FIRST AT THE TOP?
JRST ONLY1 ;YES
; TWO STRINGS TO MOVE
MOVTWO: ADD A,-1(SP) ;#CHARS(2)
HRRZ A,A ;ALLOW ROOM FOR POSSIBLE INSET
ADDM A,REMCHR(USER) ;#CHARS(NEW) - REMAINING #CHARS
SKIPLE REMCHR(USER) ;ENOUGH ROOM?
PUSHJ P,STRNGC ;NO, GO MAKE SOME
SKIPE SGLIGN(USER) ;IF ALIGNING,
PUSHJ P,INSET ; ALIGN
HRRZ B,-3(SP) ;GET 1ST # CHARS
HRROM A,-3(SP) ;COUNT RESULT
MOVE LPSA,TOPBYTE(USER);WILL BE NEW BYTE POINTER
MOVE A,LPSA ;WILL BE RESULT
EXCH A,-2(SP) ;TRADE WITH FIRST BYTE POINTER
ILDB C,A ;KNOWN NOT TO BE NULL STRING
IDPB C,LPSA ;MOVE THE STRING
SOJG B,.-2 ;RAPIDLY
HRRZ A,-1(SP) ;#CHARS(2)
JRST CATB
; ONLY ONE STRING TO MOVE
ONLY1: SKIPE SGLIGN(USER) ;CHECK ALIGNMENT?
;;#GY# SEE JUST BELOW
JSP C,CHKLGN ;YES, DON'T RETURN IF MISALIGNED
;;#GY#
;;#QE# DCS 12-30-73 Avoid problems when STRNGC expands
HRRZ A,-1(SP) ;#CHARS(2)
ADDM A,REMCHR(USER) ; - REMAINING CHARS
SKIPLE REMCHR(USER) ;ROOM?
; PUSHJ P,STRNGC ;NO
JRST [PUSHJ P,STRNGC ;no, collect, then start from scratch
MOVNS A ;since new string space may void
ADDM A,REMCHR(USER) ;the ONLY1 condition.
JRST CATGO1] ;CATGO1 is new for this fix.
;;#QE#
ADDM A,-3(SP) ;NEW #CHARS
MOVE LPSA,TOPBYTE(USER);EXTEND FROM HERE
; MOVE 2D
CATB: MOVE B,(SP) ;2D BYTE POINTER
ILDB C,B ;MOVE THIS STRING
IDPB C,LPSA ;AND MOVE IT
SOJG A,.-2 ; FAST
MOVEM LPSA,TOPBYTE(USER);PUT THIS AWAY, BY ALL MEANS
REST.4: MOVSI TEMP,RACS(USER)
BLT TEMP,C
RETFRS: SUB SP,X22 ;REMOVE NON-RESULT
JRST @UUO1(USER) ;RETURN
RETSEC: POP SP,-2(SP)
POP SP,-2(SP)
JRST @UUO1(USER) ;DIDN'T SAVE THEM
;;#GY# DCS 5-11-72 ASSURE FULL-WORD ALIGN IF SGLIGN AND ALREADY CATTED
ADJRET: SKIPE SGLIGN(USER) ;IF NEED ALIGNMENT, MUST CHECK IT
JSP C,CHKLGN ;DON'T RETURN IF NOT ALIGNED
OKLG: HRRZ TEMP,-1(SP) ;COUNT OF 2D
ADDM TEMP,-3(SP) ;INCREASE COUNT OF FIRST
JRST REST.4
CHKLGN: MOVE TEMP,-2(SP) ;Check the position field of first arg --
TLNN TEMP,300000 ;44, 01 are aligned, 35,27,17,10 not. Bits
JRST (C) ; 1 and 2 are both off only for 44 and 01.
JRST MOVTWO ;Not aligned, move both
;;#GY#
DSCR "STRING"←CHRCAT(CHAR,"STR")
⊗
HERE (CHRCAT)
HRRZ TEMP,-1(SP) ;CHECK OTHER STRING NULL
JUMPE TEMP,ITSNUL
PUSH SP,-1(SP) ;MAKE ROOM FOR ONE UNDERNEATH
PUSH SP,-1(SP)
MOVEI TEMP,-4(SP) ;NOW PUT SINGLE-CHAR STRING
PUSH TEMP,[ONECH: 1
POINT 7,RACS+5(USER),27] ;CONSTANT IN
PUSH TEMP,ONECH+1
JRST CATCGO ;GO DO SPECIAL CAT
DSCR "STRING"←CATCHR("STR",CHAR)
⊗
HERE (CATCHR)
HRRZ TEMP,-1(SP)
JUMPE TEMP,ITSNUL
PUSH SP,ONECH ;PUT ONE-CHAR DESCRIPTOR ON
PUSH SP,ONECH+1 ;TOP
CATCGO: MOVE USER,GOGTAB
POP P,UUO1(USER) ;RETURN ADDRESS
POP P,TEMP ;PUT IT SOMEWHERE SAFE
ADD TEMP,TEMP
MOVEM TEMP,RACS+5(USER)
JRST CATGO ;EVERYBODY'S NON-NULL
ITSNUL: SUB SP,X22
JRST PUTCH ;ZAP
DSCR "STRING"←CHRCHR(CHAR,CHAR)
⊗
HERE (CHRCHR)
MOVE USER,GOGTAB
MOVEM RF,RACS+RF(USER)
PUSH P,A
MOVEI A,2 ;NEED 2 CHARS
ADDM A,REMCHR(USER)
SKIPLE A,REMCHR(USER)
PUSHJ P,STRNGC ;THE USUAL
MOVE A,-3(P) ;CHAR 1
EXCH A,(P) ;GET BACK SAVED
PUSHJ P,PUTCH ;A STRING
AOS -1(SP) ;2 CHARACTER STRING
MOVE TEMP,-1(P) ;CHAR 2
IDPB TEMP,TOPBYTE(USER);A 2-CHAR STRING
SUB P,X33
JRST @3(P) ;QUICK AS A BUNNY
;;#GI#
ENDCOM (CAT)
COMPIL(PTC,<PUTCH>,<GOGTAB,STRNGC,INSET>,<PUTCH -- PUT 1 CHARACTER ROUT>)
DSCR "1-CHR STRING"←PUTCH(INTEGER);
CAL SAIL
DES CALL GENERATED BY SAIL TO MAKE A 1 CHAR STRING FROM AN INTEGER
⊗
HERE(PUTCH)
MOVE USER,GOGTAB
MOVEM RF,RACS+RF(USER)
SKIPE SGLIGN(USER)
PUSHJ P,INSET ;START ON FW BDRY
POP P,UUO1(USER)
PUSH P,A ;SAVE A
MOVEI A,1 ;COUNT FOR STRNGC
AOSLE REMCHR(USER) ;DECREASE FREE CHARS
PUSHJ P,STRNGC ; NO
POP P,A ;RESTORE A
POP P,TEMP ;GET CHARACTER
PUSH SP,[XWD 40,1] ;#CHARS
PUSH SP,TOPBYTE(USER);HERE'S WHERE IT GOES
IDPB TEMP,TOPBYTE(USER) ;STORE CHAR, UPDATE TOPBYTE(USER)
JRST @UUO1(USER) ;RETURN
ENDCOM (PTC)
COMPIL(PNT,<POINT,BBPP.>,<GOGTAB,X22,X44>,<POINT, BBPP.>)
; GETCH AND LOP NOW DONE IN LINE, NO LONGER NEEDED
HERE (BBPP.)
HERE (POINT) MOVEI A,43 ;GET LOW BIT
SUB A,-1(P)
ROT A,-6 ;NOW IN HIGH BITS
MOVE TEMP,-3(P) ;BYTE SIZE
DPB TEMP,[POINT 6,A,11]
HRR A,-2(P) ;EFFECTIVE ADDRESS.
SUB P,X44
JRST @4(P)
ENDCOM(PNT)
COMPIL(CVF,<CVF,CVG,CVE>
,<SAVE,STRNGC,RESTR,X22,X11,X33,.MT.,.CH.,.TEN.>
,<CVF, CVG, CVE>)
DSCR "STRING"←CVF(REAL);
CAL SAIL
⊗
HERE (CVF) PUSHJ P,SAVE
PUSH P,[-1]
JRST SSCONV
DSCR "STRING"←CVG(REAL);
CAL SAIL
⊗
HERE (CVG) PUSHJ P,SAVE
PUSH P,[1]
JRST SSCONV
DSCR "STRING"←CVE(REAL);
CAL SAIL
⊗
HERE (CVE) PUSHJ P,SAVE
PUSH P,[0]
JRST SSCONV
BEGIN NUMOUT
↑SSCONV:MOVE LPSA,X33
PUSHJ P,BOUND
;BOUND RETURNS AN INTEGER IN B WHICH WILL CONVERT
;TO 8 DECIMAL DIGITS.
;AN EXPONENT OF TEN IN D AND THE SIGN OF THE NUMBER IN FF
MOVM X,DIGS(USER) ;NUMBER OF DECIMALS
SKIPGE (P) ;IF F FORMAT
ADD X,D ;ADD THE TEN EXPONENT
JUMPN B,E0
JUMPN X,E0
MOVEI A,2
SKIPL (P)
MOVEM A,(P)
E0: JUMPGE X,E1
MOVEI B,0 ;THIS FIXES A BUG
JRST E2
E1: CAIL X,10
JRST E2
MOVEI Y,10 ; 0 LEQ X LESS THAN 8
SUB Y,X ;Y IS THE EXPONENT OF DIVISOR
MOVE Z,.TEN.(Y) ;Z IS THE DIVISOR
IDIV B,X↓hP&εNBαi15λh(&∞ j1α
eP4(& z)α `H$%n∀zV:⊂hP&∞εl:∃α brR⊗9rBa$$KZ∞"⊗≤Yα&→¬∩>V:"α∞εV≤*⊃αεtzR"⊗∩α∩&≡M 4(&U∩NQα+⊂4(&≤Z&B≡*↓"A$HIn&→∧1α~>∀jεP4PJε>*
αa2∃⊂H%n&t~J⊗ε≤)α∩&<JQα∞⎇*:P4PJ&∩&4Iα 1k @$%\zR"⊗∃:&N∃¬∩⊗6>4)α&PhP&ε>Rα⊃0$HInε:"α&:∞∀*εN∃∧*bB>t*:P4T)Ih&lzZ5α
b∩&≡~BVN⊗∩H4(&≤
6≡∃∧ 2`4PJ6>Z*α¬2`HIn¬α≤z:RεLrMα:,j
⊗I∧z→α∩L:&RLhP&ε∩$Iα¬1⊂H%nNL:9αεt!α∩⊗≤J6ε1¬α>&: h(&N\JB1↓E↓$4(L
∩∩%∧ 1P$KZ&→αtzQα→∧2>J6
!α↓6$ 4(&lzZ∃αRb∧$%]~εZ∃∧~"εJ ~R⊗I∧~>V: h(&6⎇25αee:∩R!E*N⊗IHIn6&tJ6V9¬~RJ&t9α2⊗t:R 4PJ∞ε6:α¬2dhP&6>4)α¬2Hh(4)ZαR"∃¬~RJ&t9α≡ε∀∩ε≡∃∧~>22,~R>I∧:>>∩L*L4(hP&ε∩$iα¬2∀*6∞"∩BVN⊗∩H%n∞D*∞-α$B⊗J∃∧JMαJ|z44(M~.&Bd)αJ⊗l~"I"-~⊗I$hP&BV≤B)αAe~RJ:<_$%ntyαJ>|h4(&E∩J=α~b∧$%\r>96T*J=1¬:&R!∧~>V: h(&B-~!αNαb 4(MαVN!¬~A2R⎇α
fR*BVN⊗∩H4(4SYα&:≤*JQαd*ε∩&t9αN&<rM1α∀bε:.~aαj⊗∀z⊗L4Ph(&N,⊃α¬2PH$%nu*6
⊗∩α>→αd*ε∩&t9αNB ~⊗L4SYm∞≡b→α∩∞~↓I5Yk9I↓!
iE%α-BRJ¬∧~"εI∧z:2e∧J→α:,99αεt!α:=¬αε∩∩Lr≥αB⎇~N&
d(4)mZ~≡1
∧~ε:∞,b2⊗⊃β⊃5a5;⊃α
⊗≤
VN∃∧Iα∞>,b∩9≡"α~&≡-∩∃α&"αε21∧zVP4PJ6>Z,Iα
1∩↓λ4(LRV6B*α¬2∃ H%n:zα2⊗ε$J:≥α≥αε∞⊗_h(&N\JB1α<"R!"-~⊗I$KZ→α~⎇∩6εPhP&*J≥!α∃LhQmm↓≤:1 4PJ*V6∧)α~→bq-H$KZ2⊗ε$J:≥αT*J>Mαiα:=¬~&≡9bα≡=α$yαj⊗∀z⊗L4PJ6>Z,Iα
1∩iλ4(LJ∩B ∧→2R>∧∩fR∃E*N⊗IHh(&6⎇2⊗%α~a AλhR∃UhLJ∩B ∧→2R>∧∩fR∃E*N⊗IHIn~&daα↑&$Aαj⊗∀zL4(M~>*≥∧ 2∃ThP&*J≥!α
DhR∃MhLJ∩B ∧→2R>∧∩fR∃E*N⊗IHIn~&daα↑&$Aα
2 r.L4PJN>*:α¬2∃_h)mmα~≡1 hR∃QhLRV6B*α~→1rYH$%\r=αNL:91α∀bε:.~αε21∧">:∀hQmm∞<a 4(Lj>Z⊗Jα
1 j⊂$%n$B⊗9α$B∃αNL:84(LJ∩B ∧→2R>∧∩fR∃E*N⊗IHh(1m↓αα∞Z→d~Z∃2≥2≥α∞|rR⊃8hP4*
P&6>4*%αic @4(M~.&Bb↓"A$hP&*J≥!α
XhP&6>4)αe2@H%n∞41α:Vl∩⊗Iα|1α∩&<JRL4PJ6>Zjα¬2∩L:M"V≤*I$%\rV6
-⊃α>→∧"⊗∞&l
2L4PJNV ¬I2∧$HInB>~α>→α$*∞&6 aαB>LrP4(LRV6B<)αe2≠($%nL1αB>≤JR&Z(h(&N,⊃αi2Hh(&6⎇25αad"&≡ME*N⊗IHh(&N-"iαe`H$%n⎇""⊗J<JN∃αT*J<4PJ*JN"α
T4T→Yh&≤*RiαJ`4(&≤Z&B≥αBA$4JRST C5
JUMPL D,C5 ;CVG IF NEG TAKE CVE
CAMLE D,X ;IF ENOUGH DIGITS
JRST C5
MOVE Y,D ;SHIFT DECIMAL POINT
MOVEI D,0 ;AND ADJUST EXPONENT
C5: PUSH P,[D1] ;RECURSIVE NUMBER PRINTER
C2: CAIE X,(Y) ;DECIMAL POINT NOW
JRST C3
SOJ Z,
MOVEI C,"." ;YES
SKIPE DIGS(USER) ;IF ZERO DIGITS
JRST C4
JUMPN B,C4
MOVEI C," "
SKIPL -1(P)
JRST C9
SOJA X,C3
C9: MOVE Y,-1(P)
CAIE Y,2
JRST C4
POP P,Y
MOVE Y,[ASCII/ 0 /]
JRST D8
C3: CAILE X,(Z) ;IF MORE THAN 8 DIGITS
JRST [MOVEI C,"0" ;PUSH A ZERO
JRST C4]
IDIVI B,=10
IORI C,"0"
C4: HRLM C,(P)
SOSL X
C8: PUSHJ P,C2
C7: HLRZ C,(P) ;PUSH NUMBER OUT
IDPB C,TOPBYTE(USER)
POPJ P,
D1: SKIPGE (P)
JRST D7
SKIPN DIGS(USER)
SOJA D,D2
JUMPE D, [MOVE Y,[ASCIZ / /] ;EXPONENT ZERO SO STORE
JRST D8] ;FOUR BLANKS
D2: SETZ Y, ;ACCUMULATE EXPONENT STRING
SETZ FF, ;EXPONENT SIGN
JUMPL D, [SETO FF, ;NEGATIVE
MOVN D,D ;MAKE POSITIVE
JRST D4]
HRLI Y," "⊗=11 ;NUMBER POS SO TRILING BLANK
D4: CAIGE D,=10
JRST [MOVEI X," "
LSHC X,-7
JRST D5]
D5: IDIVI D,=10
IORI X,"0"
LSHC X,-7 ;PUSH INTO Y
JUMPG D,D5
MOVEI X,"@" ;PUSH @
IDPB X,TOPBYTE(USER)
MOVEI X,"-" ;MINUS SIGN
SKIPE FF
D6: IDPB X,TOPBYTE(USER) ;AND EXPONENT
JUMPE Y,D7
D8: LSHC X,7
JRST D6
D7: JRST RESTR ; RETURN
; CVF,CVG,CVE CONTD.
BOUND: SETZB FF,D ;TENS EXPONENT
MOVE B,-3(P) ;INPUT NUMBER
JUMPE B,ZERO
JUMPG B,POS
;;#QB# RFS MAKE LARGEST NEG NUMBER WORK
SETOB FF,A ;NUM IS NEG
LSHC A,11 ;SEPERATE BIN EXPONENT
LSH B,-1
SETCA A, ;BIN EXPONENT + 200
JUMPE B,LARN ;LARGEST NEGATIVE???
TLO B,400000 ;
MOVNS B
JRST OK
LARN: HRLOI B,177777 ; LARGEST NEG SHIFTED RIGHT 1 BIT
AOJA A,OK
;;#QB#
POS: SETZ A,
LSHC A,11 ;SEPERATE BIN EXPONENT
LSH B,-1
OK: SUBI A,200 ;BIN EXP IN A, ABS (BIN FRACT) IN B,
;BINARY POINT LEFT OF BIT 1 SIGN OF NUMBER IN FF
CAIL A,34
JRST MULTI ;USE NEGATIVE POWERS OF TEN
CAIG A,27 ;N LESS THAN 34
JRST FRACT ;USE POSITIVE POWERS OF TEN
CAIL A,33 ;30.2 LEQ N LESS THAN 34
JRST TOPQ
CAIG A,30 ;30.2 LEQ N LESS THAN 33
JRST BOT
DONE: SUBI A,43 ;31.2 LEQ N LESS THAN 33
ASHC B,(A)
TLNE C,200000 ;ROUND
AOJ B,
ADDI D,10
ZERO: POPJ P,
TOPQ: CAMLE B,MF ;33.2 LEQ N LESS THAN 34
JRST MULTI ;33.276 LESS THAN N LESS THAN 34
JRST DONE ;33.2 LEQ N LEQ 33.276
BOT: CAMGE B,LF ;30.2 LEQ N LEQ 30
JRST FRACT ;30.2 LEQ N LESS THAN 30.230
JRST DONE ;30.230 LEQ N LESS THAN 30
; CVF,CVG,CVE CONTD.
MULTI: MOVEI X,13 ;33.276 LESS THAN N
M2: ASH D,1
ADD A,.CH.(X) ;NEGATIVE POWERS OF TEN
CAIG A,31
JRST M1 ;N LESS THAN 32
PUSHJ P,LFMP ;31.2 LESS THAN N
M6: IORI D,1 ;SET EXPONENT BIT
CAIL A,34
SOJA X,M2 ;35.2 LESS THAN N STILL TOO LARGE
CAIE A,33 ;31.2 LESS THAN N LESS THAN 34
JRST M3 ;31.2 LESS THAN N LESS THAN 33
CAMLE B,MF ;33.2 LESS THAN N LESS THAN 34
JRST M4 ;33.276 LESS THAN N LESS THAN 34
M3: ASH D,-6(X) ;33.2 LESS THAN N LEQ 33.276
JRST DONE
M1: CAIL A,30 ;N LESS THAN 32
JRST M5 ;29.2 LESS THAN N LESS THAN 32
M8: SUB A,.CH.(X) ;N LESS THAN 30 NO GOOD
SOJA X,M2 ;TRY NEXT POWER
M4: CAIE X,6 ;33.276 LESS THAN N LESS THAN 34
SOJA X,M2
MOVE B,MF ;33.276=N
JRST DONE
M5: MOVE Y,B ;SAVE B AND A
MOVE Z,A
PUSHJ P,LFMP
CAIL A,31 ;29.2 LESS THAN N LESS THAN 32
JRST M6 ;31.2 LESS THAN N LESS THAN 32
CAIG A,27 ;29.2 LESS THAN N LESS THAN 31
JRST M7 ;29.2 LESS THAN N LESS THAN 30
CAML B,LF ;30.2 LESS THAN N LESS THAN 31
JRST M6 ;30.230 LESS THAN N LESS THAN 31
CAILE X,6 ;30.2 LESS THAN N LESS THAN 30.230
JRST M7 ;STILL SOME TO GO
MOVE B,LF ;B=30.230
JRST M6
M7: MOVE B,Y ;RESTORE
MOVE A,Z
JRST M8
; CVF,CVG,CVE CONTD.
FRACT: MOVEI X,5 ;N LESS THAN 30.230
L2: ASH D,1
ADD A,.CH.(X)
CAIL A,33
JRST L1 ;32.2 LEQ N
PUSHJ P,LFMP ;N LESS THAN 33
L6: IORI D,1
CAIGE A,30
SOJA X,L2 ;N LESS THAN 30
CAIE A,30 ;30.2 LEQ N LESS THAN 33
JRST L3 ;31.2 LEQ N LESS THAN 33
CAMGE B,LF ;30.2 LEQ N LESS THAN 31
JRST L4 ;30.2 LEQ N LESS THAN 30.230
L3: ASH D,(X) ;30.2300 LEQ N LESS THAN 31
L9: MOVNS D
JRST DONE
L1: CAIG A,34 ;32.2 LEQ N
JRST L5 ;32.2 LEQ N LESS THAN 35
L8: SUB A,.CH.(X) ;34.2 LEQ N
SOJA X,L2
L4: SOJGE X,L2 ;30.230 LEQ N LESS THAN 31
MOVE B,LF ;N30.230
JRST L9
L5: MOVE Y,B ;SAVE B AND A
MOVE Z,A
PUSHJ P,LFMP
CAIG A,32 ;32.2 LEQ N LESS THAN 35
JRST L6 ;32.2 LEQ N LESS THAN 33
CAIL A,34 ;33.2 LEQ N LESS THAN 35
JRST L7 ;34.2 LEQ N LESS THAN 35
CAMG B,MF ;33.2 LEQ N LESS THAN 34
JRST L6 ;33.2 LEQ N LESS THAN 34
JUMPG X,L7 ;33.276 LESS THAN N LESS THAN 34
MOVE B,MF ;N=33.276
JRST L6
L7: MOVE B,Y ;RESTORE
MOVE A,Z
JRST L8
LFMP: MUL B,.MT.(X)
TLNE B,200000
POPJ P,
ASHC B,1
SOJA A,.+1
POPJ P,
LF: 230455000000
MF: 276570177400
BEND
ENDCOM(CVF)
COMPIL(SUB,<SUBST,SUBSR>,<SAVE,RESTR,X22,.SKIP.,GOGTAB>,<SUBSTRING ROUTINES>)
DSCR "STRING"←SUBST("STRING",END CHAR,STARTING CHAR);
CAL SAIL
DES CALL GENERATED BY SAIL FOR STR[X FOR Y] OPERATION
⊗
HERE (SUBST)
MOVE LPSA,-2(P) ;END LOC
JRST SBSTR ;GO FINISH UP
; SUBSI NO LONGER NEEDED, REMOVED
DSCR "STRING"←SUBSR("STRING",#CHARS, START CHAR #);
CAL SAIL
DES CALL GENERATED BY SAIL FOR STR[X TO Y] OPERATION
ALGORITHM IS AS FOLLOWS:
1) !SKIP!←FALSE; "NOSKIP" IF ALL OK
< 2) IF END LOC > LENGTH, REPLACE IT BY LENGTH, (RH(!SKIP!)←TRUE;
3) NOW IF START < 1 OR END-START < -1 (-1 means ZERO LENGTH REQUEST),>>
LH(!SKIP!)←TRUE, SET START TO 1 OR LENGTH+1
4) ADJUST LENGTH AND BP IN DESCRIPTOR
NOTICE THAT STR[INF+1 TO INF+1+(non-neg integer)] IS LEGAL, RETURNING NULL,
AND TURNING ON !SKIP!
⊗
HERE (SUBSR)
SOS LPSA,-2(P) ;#CHARS
ADD LPSA,-1(P) ;-1 + START = END
SBSTR: MOVE TEMP,GOGTAB ;FOR A MOMENT
POP P,UUO1(TEMP) ;SAVE RETURN -- NONSTANDARD!!
SETZM .SKIP. ;ASSUME ALL OK
MOVE USER,(P) ;START LOC
HRRZ TEMP,-1(SP) ;LENGTH OF STRING
JUMPL LPSA,[ TDZA LPSA,LPSA ;END LOC CANNOT BE NEGATIVE
NO4: MOVE LPSA,TEMP ;NOR GREATER THAN LENGTH
HLLOS .SKIP. ;TELL THE USER END WAS WRONG
JRST OKS1]
CAMLE LPSA,TEMP ;END LOC CANNOT BE GREATER THAN LENGTH
JRST NO4
OKS1: CAIL USER,1(LPSA) ;NEW STRING MUST HAVE NON-NEG LENGTH
JRST NO1 ;ADJUST TO 1(LPSA)
JUMPLE USER,[NO2: MOVEI USER,1 ;NON-POS, ADJUST TO 1
JRST NO3
NO1: MOVEI USER,1(LPSA) ;1 PAST END OF REQUEST
NO3: HRROS .SKIP. ;TELL USER START IS BAD
JRST OKS] ;NOW CAN DO SUBSTRING
OKS: SUBI LPSA,-1(USER) ;NEW STRING LENGTH
HRRM LPSA,-1(SP) ;GET RID OF IT, FORGET IT
MOVE LPSA,(SP) ;BP
LDB TEMP,[POINT 3,LPSA,5]
TRC TEMP,4 ;# CHARS FROM BEG OF CURRENT BP
ADDI TEMP,-1(USER) ;+ # ADDITIONAL CHARS DUE TO SUBSTR
CAILE TEMP,4 ;CAN WE AVOID DIV OR SUB?
JRST DIVSUB ;NO
GETPTF: HLL LPSA,PTBL(TEMP) ;GET POINTER AND SIZE FIELDS
PTWAY: MOVEM LPSA,(SP) ;RESULT BP
SUB P,X22 ;RID SELF OF ARGUMENTS
JRST @3(P) ;RETURN
DIVSUB: CAILE TEMP,9 ;CAN WE AVOID DIV?
JRST DIV ;NO
SUBI TEMP,5 ;PUT # IN RANGE 0 TO 4
ADDI LPSA,1 ;INCREMENT BP
JRST GETPTF ;FINISH UP
; N.B. -- LPSA=13, TEMP=14, USER=15 -- CHANGE THIS CODE IF YOU MODIFY THESE
; ASSIGNMENTS
DIV: IDIVI TEMP,5 ;# WORDS TO USER, # CHARS TO TEMP
ADD LPSA,TEMP ;INCREMENT BP ADR FIELD
HLL LPSA,PTBL(USER) ;GET POINTER AND SIZE FIELDS
JRST PTWAY ;FINISH UP
PTBL: POINT 7,0
POINT 7,0,6 ;POINTER AND SIZE FIELDS FOR 7-BIT BYTES
POINT 7,0,13
POINT 7,0,20
POINT 7,0,27
POINT 7,0,35
ENDCOM (SUB)
COMPIL(EQU,<EQU>,<X44>,<EQU>)
DSCR BOOLEAN←EQU("STR1","STR2");
CAL SAIL
⊗
HERE (EQU)
; NOTE USER NOT SET UP BECAUSE CAN BE NO ERROR MESSAGES
PUSH P,B ;SAVE EXTRA AC
HRRZ A,-1(SP) ;LENGTH OF ONE STRING
HRRZ B,-3(SP) ;LENGTH OF THE OTHER
CAME A,B ;SAME?
JRST NOTEQ ; NO, NOT EQUAL STRINGS
MOVE LPSA,(SP) ;ONE BYTE POINTER
MOVE USER,-2(SP) ;THE OTHER
JRST CLUP1 ;ENTER THE LOOP AT ITS BASE
CLUP: ILDB TEMP,LPSA ;ONE CHAR
ILDB B,USER ;ANOTHER
CAMN TEMP,B ;QUIT IF NOT EQUAL
CLUP1: SOJGE A,CLUP ;CONTINUE UNTIL ALL PERUSED OR SOME NOT EQUAL
JUMPL A,.+2 ;IF -1, THEY'RE EQUAL, USE -1 TO BE TRUE
NOTEQ: MOVEI A,0 ;NOT EQUAL
POP P,B ;RESTORE AC
SUB SP,X44 ;GET RID OF ARGS
POPJ P, ;RETURN
ENDCOM (EQU)
COMPIL(CVD,<CVD,CVO>,<SAVE,RESTR,X11,X22>,<CVD AND CVO ROUTINES>)
DSCR INTEGER←CVD("STRING");
CAL SAIL
⊗
HERE (CVD)
PUSHJ P,SAVE
MOVEI A,=10
JRST CV
DSCR INTEGER←CVO("STRING");
CAL SAIL
⊗
HERE (CVO)
PUSHJ P,SAVE
JOV .+1 ;CLEAR ANY OVERFLOWS
MOVEI A,10
CV: SETZB B,Y ;COLLECT RESULT IN B, Y IS +/- FLAG
MOVE LPSA,X11
HRRZ C,-1(SP) ;STRING COUNT
MOVE D,(SP) ;BYTE POINTER
CVL: SOJL C,CVDUN
ILDB X,D ;GET A CHAR
CAIG X," " ;IGNORE LEADING " "s AND SUCH
JRST CVL
CAIN X,"-" ;NEGATIVE?
TLCA Y,10000 ;NEGATE PREVIOUS NOTION
CAIN X,"+" ;PLUS?
JRST CVL ; GO BACK FOR MORE LEADING "BLANKS"
; NOW IT IS A DIGIT OR THE END
CNV: CAIL X,"0" ;IN RANGE?
CAIL X,"0"(A) ;A IS RADIX
JRST CVDUN ;NOT IN RANGE, DONE
IMUL B,A ;NUM=NUM*10+NEWDIG
;; #QI# THESE THREE USED TO BE DOWN AT CVDUN
JOV [CAIN A,10 ;CVO?
TLC B,400000 ;YES, THIS SPECIAL HACK ALLOWS TYPING AN
JRST .+1] ;UNSIGNED OCTAL NO. WITH BIT 0 ON
;; #QI#
ADDI B,-"0"(X)
SOJL C,CVDUN ;DONE WHEN NEGATIVE
ILDB X,D
JRST CNV
CVDUN:
IOR Y,[MOVEM B,RACS+1(USER)] ;MOVEM OR MOVNM
XCT Y
SUB SP,X22
JRST RESTR
ENDCOM(CVD)
COMPIL(CVS,<GETFORMAT,SETFORMAT,CVS,CVOS>
,<GOGTAB,INSET,X33,SAVE,RESTR,X11,X22,STRNGC>
,<GETFORMAT, SETFORMAT, CVS, CVOS ROUTINES>)
DSCR "STR"←CVS(INTEGER);
CAL SAIL
⊗
HERE(CVS) PUSHJ P,SAVE
PUSHJ P,CVSET ;SET UP FOR CONVERSION
MOVEI D,=10 ;WILL DIVIDE DECIMAL
SKIPL B,-2(P) ;IF NUMBER IS NEGATIVE,
JRST FRNP ; PRINT A MINUS SIGN,
MOVM B,B ;PRINT ABS VALUE
JFCL 10,.+1 ;
MOVEI Y,"-" ;Y IS NOT ZERO, SIGNALS BLKIN BELOW
MOVEI A,1 ;ACCOUNT FOR EXTRA CHARACTER
;; #PG# (1 OF 2) MAKE CVS WORK FOR '400000000000
JUMPGE B,FRNP ;GO PRINT
; ACCOUNT FOR LARGEST NEGATIVE NUMBER ('400000,0)
MOVE B,[=3435973836] ;34359738368 IS LARGEST NUMBER REP IN MACHINE
MOVEI C,"8"
HRLM C,(P) ;PUT ON STACK
AOJA A,FRNP1 ;ACCOUNT FOR CHARACTER
;; #PG#
DSCR "STR"←CVOS(INTEGER);
CAL SAIL
⊗
HERE (CVOS) PUSHJ P,SAVE
PUSHJ P,CVSET
MOVEI D,10 ;OCTAL DIVIDE
MOVE B,-2(P) ;GET THE DATA
LSHC B,-3 ;MAKE SURE NUMBER BEING
LDB C,[POINT 3,C,2] ;DIVIDED IS + BY SIMULATING
JRST FRNX ; THE FIRST RESULT.
FRNP: IDIV B,D ;FAMOUS RECURSIVE NUMBER PRINTER
FRNX: IORI C,"0"
HRLM C,(P)
ADDI A,1
JUMPE B,BLKIN ;GO TEST FOR LEADING BLANKS
;; #PG# ! LABEL OTHER ENTRY POINT
FRNP1: PUSHJ P,FRNP
POPOFF: HLRZ C,(P)
IDPB C,TOPBYTE(USER)
POPJ P,
BLKIN: MOVEI D," " ;GIVE LEADING BLANKS IF WDTH POS,
SKIPL WDTH(USER) ; LEADING 0'S IF NEG.
JRST LEDBLK ;BLANKS
MOVEI D,"0"
JUMPE Y,LEDBLK ;NEGATIVE?
IDPB Y,TOPBYTE(USER) ;YES, PUT IN SIGN
MOVEI Y,0 ;DON'T DO IT AGAIN!
LEDBLK: CAML A,X ;NEED MORE FILL?
JRST POPOF1 ; NO
IDPB D,TOPBYTE(USER) ; YES, DROP IN ONE MORE
AOJA A,LEDBLK ;AND CONTINUE
POPOF1: JUMPE Y,POPOFF ;NEGATIVE, WERE FILLING BLANKS
IDPB Y,TOPBYTE(USER) ; YES, PUT SIGN IN AFTER BLANKS
JRST POPOFF ;GO PUT OUT NUMBER
FRNPDN: HRROM A,-1(SP) ;CHAR COUNT, NON-CONST STRING
MOVEI TEMP,=15 ;GIVE BACK WHAT WASN'T USED
CAMGE TEMP,X ; (15 IF GT WDTH, ELSE WDTH
MOVE TEMP,X ; USED FOR CALCULATION)
SUB A,TEMP
ADDM A,REMCHR(USER) ;UPDATE REMCHR
JRST RESTR
CVSET:
SKIPE SGLIGN(USER) ;IF ALIGNING,
PUSHJ P,INSET ; ALIGN
MOVE LPSA,X22
MOVM X,WDTH(USER) ;TOTAL FIELD SIZE, UNLESS NUMBER IS BIGGER
MOVEI A,=15 ;CHECK THAT THERE WILL
CAMGE A,X ; BE ROOM FOR THE NUMBER
MOVE A,X ; (USE 15 OR WDTH, WHICHEVER IS BIGGER
ADDM A,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC ;NO ROOM
MOVEI A,0
MOVEI Y,0 ;NOT NEG AS OF YET
PUSH SP,A ;A IS COUNT, SAVE STRING NO WORD SPACE
PUSH SP,TOPBYTE(USER);AND RESULTANT BYTE POINTER
POP P,D ;RETURN ADDR
PUSH P,[FRNPDN] ;CALLED IN-LINE FIRST TIME
JRST (D)
HERE (SETFORMAT)
MOVE USER,GOGTAB
POP P,TEMP ;RETURN ADDRESS
POP P,DIGS(USER) ;#DIGS TO RIGHT OF .
POP P,WDTH(USER) ;TOTAL FIELD WIDTH
JRST (TEMP)
DSCR GETFORMAT(@WIDTH,@DIGS);
CAL SAIL
⊗
HERE(GETFORMAT)
MOVE USER,GOGTAB
MOVEW (<@-1(P)>,<DIGS(USER)>)
MOVEW (<@-2(P)>,<WDTH(USER)>) ;GIVE USER RESULTS
SUB P,X33
JRST @3(P) ;RETURN
ENDCOM(CVS)
COMPIL(SCN,<SCAN,BKTCHK>,<INSET,SAVE,RESTR,X44,STRNGC,BRKMSK,CORGET>,<SCAN ROUTINE>)
DSCR "STR"←SCAN(@"STRING",BRKTBL,@BRCHAR);
CAL SAIL
⊗
HERE (SCAN) PUSHJ P,SAVE
SKIPE SGLIGN(USER)
PUSHJ P,INSET
MOVE LPSA,X44
SOS C,-3(P) ;PTR TO STRING TO BE SCANNED
HRRZ A,(C) ;#CHARS IN INPUT STRING
;;%BK% USED TO DO GC CHECKING HERE (NOW DO IT LATER)
JUMPE A,NULSCN ;IF NO CHARS TO SCAN
MOVE B,1(C) ;INPUT BYTE POINTER
MOVEI Z,0
MOVE X,-2(P) ;TABLE #
MOVEI TEMP,-1 ;ERROR IF BLOCK NOT THERE OR NOT INIT'ED
PUSHJ P,BKTCHK ;CHECK OUT TABLE #
JRST ENDSCN ;ERROR OF SOME SORT
;CHNL IS NOW 1 TO 18, CDB POINTS AT CORGET BLOCK
SCNNX: MOVE D,BRKMSK(CHNL) ;HAS BITS ON FOR THIS TABLE
TRNE D,@BRKCVT(CDB) ;WANT CONVERSION?
;;%##% LDE 3-JAN-73 LET US ALLOW LOWER TO UPPER CASE CONVERSION
TLOA C,400000 ; YES
TLZ C,400000 ; NO
SETZM @-1(P) ;BREAK CHAR WORD
MOVE Y,CDB
ADD Y,[XWD X,BRKTBL];RLC+BRKTBL(CDB)
ADD CHNL,CDB ;RELOCATE 1 TO 18
;;%BK% SEE IF WE MUST COPY
TRNN D,@BRKOMT(CDB) ;COPY IF OMIT CHARS
JUMPGE C,NOCPY ;OR IF DOING CONVERSION
ADDM A,REMCHR(USER) ;WE MUST COPY THE STRING
SKIPLE REMCHR(USER) ;THE "OUT OF SPACE DANCE"
PUSHJ P,STRNGC
PUSH SP,A
PUSH SP,TOPBYTE(USER) ;RESULT BYTE POINTER
;;%SW% ! the garbage collector may get in
MOVE B,1(C) ;GET BYTE POINTER BACK
SCNLUP: SOJL A,SCNDUN ;STRING EXHAUSTED
ILDB X,B ;GET A CHAR
;;%##% UC CONVERSION
JUMPGE C,NOCNVS ;ONLY CONVERT IF WANTED
CAIL X,"a"
CAILE X,"z"
JRST .+2
TRZ X,40 ;MAKE IT UPPER CASE
NOCNVS: TDNE D,@Y ;TDNE D,BRKTBL+RLC(X)
JRST SCNSPC ;OMIT OR BREAK
IDPB X,TOPBYTE(USER)
AOJA Z,SCNLUP
SCNSPC: HLLZ TEMP,@Y ;NOW SEE IF WE
TDNN TEMP,D ;OMIT OR BREAK
JRST SCNLUP ; OMIT
SCNBRK: MOVEM X,@-1(P) ;SET BREAK CHAR WORD
SCNDUN: SKIPN TEMP,DSPTBL(CHNL) ;WHAT DO WE DO WITH BRCHAR?
JRST ENDSCN ; NOTHING
JUMPL TEMP,SCNAPN ;APPEND TO END OF STRING
SCNRET: SOS B ;LEAVE FOR NEXT TIME
REPEAT 4,<IBP B
>
JUMPL A,ENDSCN ;STRING WAS EXHAUSTED
AOJA A,ENDSCN ;PUT ONE BACK
SCNAPN:
;;#FM# 11-15-71 DCS (1-1)
JUMPL A,ENDSCN ;SCANNED OFF END, NOTHING LEFT TO APPEND
;;#FM#
IDPB X,TOPBYTE(USER)
ADDI Z,1
;;#GI# DCS 2-5-72 REMOVE TOPSTR
ENDSCN: MOVE TEMP,Z ;#CHARS IN NEW STRING
SUB TEMP,-1(SP) ;NUMBER RESERVED BUT NOT USED
ADDM TEMP,REMCHR(USER);UNRESERVE THEM
HRROM Z,-1(SP) ;NOT A CONSTANT, NEW STRING SIZE
JUMPGE A,.+2 ;IF EXHAUSTED, USE 0
MOVEI A,0
HRRM A,(C) ;UPDATE OLD COUNT
;;#GI#
MOVEM B,1(C) ;UPDATED ORIGINAL BYTE POINTER
JRST RESTR ;POPJ P,
NULSCN: SETZM @-1(P) ;NO BREAKS
;;%BK%
PUSH SP,A ;NULL STRING RESULT
PUSH SP,A ;
JRST RESTR
NOCPY: PUSH SP,(C) ;COPY COUNT WRD FROM INPUT (WILL MUNCH)
PUSH SP,1(C) ;BYTE POINTER TO START
;;#TF# (=D4=) LDE ! IF NO BREAK CHAR, DON'T HANDLE ONE
SCNLP2: SOJL A,ENDSC2 ;COUNT DOWN
ILDB X,B ;GET NEXT CHAR
TDNN D,@Y ;IS BREAK CHAR ON (KNOW NOT OMIT)
AOJA Z,SCNLP2 ;JUST REGULAR
MOVEM X,@-1(P) ;IT WAS THE BREAK CHAR
SCNDN2: SKIPN TEMP,DSPTBL(CHNL) ; FIGURE OUT WHAT TO DO WITH BRK CHR
JRST ENDSC2 ;NICHTS
JUMPL TEMP,SCNAP2 ;APPEND IT
; SOS B ;BACK UP BYTE POINTER TO LEAVE CHAR
; IBP B ;
;; IBP B ;
; IBP B ;
; IBP B ;
;; JRL - FOLLOWING "OPTIMIZATION" FOR ABOVE CODE DUE TO REG
;;#TH# RHT 9-16-74 THE ADD & SUBTRACT CAN OVERFLOW
ADD B,[070000,,0] ;BACK UP BYTE POINTER
JFCL 17,.+1 ;SO OVERFL STAYS HAPPY
JUMPG B,.+3
SUB B,[430000,,1] ;BACK UP ONE WORD WHEN NECESSARY
JFCL 17,.+1 ;SO OVERFL STAYS HAPPY
;
AOJA A,ENDSC2 ;& WE HAVE ONE MORE LEFT
SCNAP2: ADDI Z,1 ;APPEND ONE MORE CHAR TO RESULT
ENDSC2: HRRM Z,-1(SP) ;
CAIGE A,0 ;NEVER PUT NEG COUNT
MOVEI A,0 ;THERE YOU GO
HRRM A,(C) ;FIX INPUT BYTE CNT
MOVEM B,1(C) ;NEW INPUT BYTE PTR
JRST RESTR ;ALL DONE
;;%BK%
DSCR BKTCHK
Checks break table number for break table routines
(SCAN,INPUT,TTYIN,PTYIN,BREAKSET,STDBRK)
CAL PUSHJ P,BKTCHK
PAR USER set up
X break table number
TEMP flags
left half: what to do if CORGET block is not there
0→error, -1→get a block
right half: whether table must be initialized
0→no, -1→yes
SID uses X,Y,CDB,CHNL (also B,C if it is necessary to call CORGET)
RET +1 error of some sort
+2 no error. CDB points at the CORGET block
CHNL is the table number modulo 18 in the range 1 to 18
⊗
HERE(BKTCHK)
;;#%%# ! MAKE BREAKTABLE 0 A SPECIAL CASE JFR 11-2-74
JUMPE X,.BKCKZ
ADDI X,=17 ;TABLE # NOW IN RANGE 0 THROUGH 71
SKIPN BKTPRV(USER) ;PRIVILEGED?
CAIL X,=18 ;LOWEST FOR ORDINARY USERS
CAILE X,=71 ;MAX FOR EVERYBOCY
;;#TP# BETTER ERROR MESSAGE JFR 10-26-74
JRST [MOVE X,X
ERR <BKTCHK: Breaktable out of range: >,7
JRST CPOPJ]
IDIVI X,=18
MOVEI CHNL,1(Y) ;CHNL NOW IN RANGE 1 TO 18
MOVE Y,X ;SAVE FOR POSSIBLE ERROR MESSAGE
ADD X,USER ;RELOCATE GROUP NUMBER
SKIPN CDB,BKTPTR(X) ;POINTER TO COREGET BLOCK
JRST .BKCKN ;BLOCK NOT THERE
TRNN TEMP,-1 ;NEED INITIALIZATION?
JRST CPOPJ1 ;NO
HRRZ X,BKJFFO(CDB) ;INITIALIZATION BITS
TDNN X,BRKMSK(CHNL) ;WAS IT INIT'ED?
;;#TP# BETTER ERROR MESSAGE JFR 10-26-74
JRST [.BKCKE: IMULI Y,=18 ;RECONSTUCT THE NUMBER SO WE CAN DISPLAY IT
ADD Y,CHNL
SUBI Y,=18
ERR <BKTCHK: Uninitialized break table: >,7
JRST CPOPJ]
CPOPJ1: AOS (P) ;SUCCESS, SKIP RETURN
CPOPJ: POPJ P,
.BKCKN: JUMPGE TEMP,.BKCKE ;IF INIT REQ'D AND BLOCK NOT THERE, ERROR
PUSH P,CHNL ;SAVE 1 TO 18
PUSH P,X ;SAVE LOCATION FOR POINTER
MOVEI C,BRKDUM+1 ;AMOUNT TO GET
PUSHJ P,CORGET
ERR <BKTCHK: CORGET failed>
MOVE CDB,B ;ADDR OF BLOCK
SETZM (B) ;CLEAN IT OUT
HRLI B,(B) ;
HRRI B,1(B)
BLT B,BRKDUM(CDB) ;
POP P,X
POP P,CHNL
MOVEM CDB,BKTPTR(X) ;SAVE FOR FUTURE REFERENCE
JRST CPOPJ1 ;SUCCESS
;;#%%# MAKE SPECIAL CASE FOR BREAKTABLE 0 JFR 11-2-74
.BKCKZ: SETZ CHNL, ;CHEAT ON "RANGE 1 TO 18"
MOVEI X,1(USER)
SKIPN CDB,BKTPTR(X) ;POINTER FOR CORGET BLOCK, TABLES 1 TO 18
JRST .BKCKN+1 ;CORGET BLOCK NOT THERE: FETCH, FIDO
JRST CPOPJ1 ;SUCCESS
ENDCOM(SCN)
COMPIL(CVC,<CVSIX,CVASC,CVSTR,CVXSTR,CV6STR,CVASTR>,<SAVE,RESTR,X11,X22,INSET,STRNGC,FLSCAN>
,<CVSIX, CVASC, CVSTR, CVXSTR, CV6STR -- CHARACTER CONVERSION ROUTINES>)
DSCR SIXBIT INTEGER←CVSIX("STRING");
CAL SAIL
⊗
;;#LA# THIS ROUTINE USED TO CALL FILNAM
HERE (CVSIX)
MOVEI A,0 ;WILL DPB THE SIXBIT INTO HERE
HRRZ TEMP,-1(SP) ;BYTE COUNT
JUMPE TEMP,CVSXX ;NULL
CAILE TEMP,6 ;ONLY USE FIRST SIX CHARS
MOVEI TEMP,6 ;
MOVE LPSA,[POINT 6,A];
PUSH P,B ;NEEDED 1 MORE AC
MOVE B,(SP) ;BYTE POINTER
CVSXXL: ILDB USER,B ;THE CHARACTER
TRZN USER,100 ;MOVE 100 BIT TO 40
TRZA USER,40 ;
TRO USER,40 ;
IDPB USER,LPSA ;PUT AWAY
SOJG TEMP,CVSXXL ;LOOP
POP P,B ;GET BACK THE EXTRA AC
CVSXX: SUB SP,X22 ;EXIT
POPJ P,
DSCR ASCII INTEGER←CVASC("STRING");
CAL SAIL
⊗
HERE (CVASC)
PUSHJ P,SAVE
POP SP,X
POP SP,B
HRRZS B ;STRING ARG
MOVEI C,5
MOVE D,[POINT 7,A]
MOVEI A,0
LUP: SOJL B,DUNN
ILDB Y,X
IDPB Y,D
SOJG C,LUP ;COLLECT CHARS IN A
DUNN: MOVEM A,RACS+1(USER) ;RESULT
MOVE LPSA,X11
JRST RESTR
DSCR "STR"←CVSTR(ASCII INTEGER);
CAL SAIL
⊗
HERE (CVSTR)
PUSHJ P,SAVE
MOVEI A,5
ADDM A,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC
PUSHJ P,INSET ;ALIGN TO FW BDRY
;;#GI# DCS 2-5-72 REMOVE TOPSTR
PUSH SP,[XWD 40,5] ;BEST NON-CONSTANT STRING REP
;;#GI#
PUSH SP,TOPBYTE(USER)
MOVEW @TOPBYTE(USER),-1(P)
AOS TOPBYTE(USER)
MOVE LPSA,X22
JRST RESTR
DSCR "STR"←CVXSTR(SIXBIT INTEGER);
CAL SAIL
⊗
HERE (CVXSTR)
PUSHJ P,SAVE
;;%BW% !
MOVEI C,0 ;A FLAG
CVXST1: SKIPE SGLIGN(USER)
PUSHJ P,INSET
MOVEI A,6
ADDM A,REMCHR(USER) ;UPDATE REMAINING CHAR COUNT
SKIPLE REMCHR(USER) ;IS THERE ROOM FOR THIS STRING?
PUSHJ P,STRNGC ;NO, TRY TO GET IT
;;#GI# DCS 2-5-72 REMOVE TOPSTR
PUSH SP,[XWD 40,6] ;NON-CONST,,COUNT FOR RESULT
;;#GI#
PUSH SP,TOPBYTE(USER) ;RESULT STARTS HERE
MOVEI A,6
MOVE B,[POINT 6,-1(P)] ;POINT AT INPUT SIXBIT
;;%BW% MAKE THIS CODE WORK FOR CV6STR TOO
CVXLP: ILDB TEMP,B ;GET A SIXBIT CHAR
JUMPE C,CVXST2
JUMPE TEMP,CVXST3
CVXST2: ADDI TEMP,40 ;CONVERT TO ASCII
IDPB TEMP,TOPBYTE(USER) ;PUT IN RESULT STRING, UPDATE TOPBYTE
SOJG A,CVXLP ;DO IT ALL
CVXST3: MOVN A,A ;MAKE REMCHR HONEST
ADDM A,-1(SP) ;AS WELL AS BYTE CNT IN STRING
ADDM A,REMCHR(USER)
MOVE LPSA,X22 ;REMOVE ARG, RETURN ADDRESS
JRST RESTR ;AND RETURN
DSCR "STR"←CV6STR(SIXBIT INTEGER);
CAL SAIL
DES LIKE CVXSTR BUT STOPS ON SPACE.
⊗
HEREFK(CV6STR,CV6ST.)
PUSHJ P,SAVE
MOVEI C,1
JRST CVXST1
;;%BW% ↑
;;%CA%
DSCR "STR"←CVASTR(INTEGER)
CAL SAIL
DES LIKE CVSTR BUT STOPS ON A NULL CHARACTER
⊗
HEREFK(CVASTR,CVAST.)
PUSHJ P,SAVE
MOVEI A,5 ;BE SURE HAVE ENOUGH ROOM
ADDM A,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC
PUSH SP,[XWD 40,5] ;STERILE STRING CNT WD
PUSH SP,TOPBYTE(USER) ;WHAT THE DESCR WILL BE
MOVE 4,-1(P); ;
MOVEI 5,0 ;
MOVNI A,5 ;
MOVE TEMP,[POINT 7,4] ;
CVALP: ILDB C,TEMP ;PICK UP A CHARACTER
JUMPE C,CVALDN ;DONE WHEN SEE NULL
IDPB C,TOPBYTE(USER) ;PUT IT DOWN
AOJA A,CVALP
CVALDN: ;CORRECT REMCHR
ADDM A,REMCHR(USER)
ADDM A,-1(SP) ;AND STRING DESCR
MOVE LPSA,X22 ;RETURN
JRST RESTR
;; %CA% ↑
ENDCOM(CVC)
COMPIL(CVL,<CVFIL>,<SAVE,RESTR,X22,X33,FILNAM,.SKIP.>,<CVFIL>)
DSCR SIXBIT INTEGER←CVFIL("FILE STRING",@RESULT EXTENSION,@RESULT PPN);
CAL SAIL
⊗
HERE (CVFIL)
PUSHJ P,SAVE
SETZM .SKIP. ;ASSUME NO PROBLEMS
PUSHJ P,FILNAM ;GET FILENAME COMPONENTS FROM STRING ARG
SETOM .SKIP. ;NO GOOD SPEC, REPORT IF HE'S INTERESTED
MOVE TEMP,FNAME(USER)
MOVEM TEMP,RACS+1(USER) ;AMJOR RESULT (NAME) TO R1
MOVE TEMP,FNAME+1(USER)
MOVEM TEMP,@-2(P) ;EXTENSION TO REF ARG.
MOVE TEMP,FNAME+3(USER)
MOVEM TEMP,@-1(P) ;PPN TO REF ARG.
MOVE LPSA,X33
JRST RESTR
ENDCOM(CVL)
COMPIL(BRK,<BREAKSET,SETBREAK,STDBRK,GETBREAK,RELBREAK>
,<SAVE,RESTR,BRKMSK,BKTCHK,SIMIO,GOGTAB,X22,X33,OPEN,LOOKUP,ARRYIN,RELEASE,.SKIP.,X11,CORGET,CORREL>
,<BREAKSET, SETBREAK, STDBRK ROUTINES>)
DSCR BREAKSET(TABLE #,"STRING",WAY);
CAL SAIL
⊗
HERE(BREAKSET)
PUSHJ P,SAVE ;SAVE ACS AND THINGS
MOVE LPSA,X33
SUB SP,X22
MOVE X,-2(P) ;TABLE #
MOVSI TEMP,-1 ;GET BLOCK IF NOT THERE, NO NEED TO INIT
PUSHJ P,BKTCHK ;CHECK OUT TABLE #
JRST RESTR ;ERROR RETURN
MOVE B,BRKMSK(CHNL) ;BITS FOR THIS TABLE
IORM B,BKJFFO(CDB) ;MARK THIS TABLE RESERVED & INIT'ED
HLLZS B ;LEFT HALF ONLY
ADD CHNL,CDB ;RELOCATE RANGE 1-18
MOVE C,[ANDCAM B,(D)] ;USUAL CLEARING INSTR
LDB X,[POINT 4,-1(P),35] ;COMMAND
TRZN X,10 ;LEFT OR RIGHT HALF OF TABLE?
SKIPA X,BKCOM(X) ;RIGHT HALF
HLRZ X,BKCOM(X) ;LEFT HALF
JRST (X) ;DISPATCH
BKCOM: XWD XCLUDE,PASLINS ;X,,P
XWD INCL,PENDCH ;I,,A
XWD ILLSET,RETCH ;-,,R
;;%##% ADD BREAK MODE FOR COERCIONS
XWD UCASE,SKIPCH ;K,,S
XWD BRKLIN,RESTR ;L,,D
XWD ILLSET,ERMAN ;-,,E
;;%BG% ! ADD WAY TO UNDO "K"
XWD NOLINS,LCASE ;N,,F
XWD OMIT,ILLSET ;O,,-
ILLSET: ERR <ILLEGAL COMMAND TO BREAKSET>,1
JRST RESTR
;;%BK% OMISION NOW MUST SET ANOTHER FLAG, TOO
;;XCLUDE: SKIPA C,[IORM B,(D)] ;YES, SET ALL TO 1 TO INITIALIZE
;;OMIT: MOVSS B ;OMIT, PUT BIT IN RH
XCLUDE: MOVE C,[IORM B,(D)] ;EXCLUSION MEANS YOU FIRST SET TO ONE
JRST INCL ;GO DO IT
OMIT: MOVSS B ;OMIT HAS BIT IN RH
HRRZ A,1(SP) ;SET BIT ONLY IF HAVE SOME OMIT CHARS
IORM B,BRKOMT(CDB) ;ASSUME HAVE SOME
CAIN A,0 ;HAVE ANY
ANDCAM B,BRKOMT(CDB) ;NO
;;%BK%
INCL: MOVSI D,-200
HRRI D,BRKTBL(CDB) ;RELOCATABLE IOWD
BRKLUP: XCT C ;CLEAR (OR SET) PROPER (HALF OF PROPER) TABLE
AOBJN D,BRKLUP
MOVE C,[IORM B,BRKTBL(D)] ;USUAL SETTING INSTR
CAIN X,XCLUDE ;BY EXCEPTION?
MOVE C,[ANDCAM B,BRKTBL(D)] ;YES, WANT TO TURN OFF BITS
ADDI C,(CDB) ;RELOCATE IT
HRRZ A,1(SP) ;LENGTH OF STRING
MOVE X,2(SP) ;BYTE POINTER
JRST BRKL2
BRKL1: ILDB D,X ;GET A CHAR
XCT C ;DO RIGHT THING TO RIGHT BIT
BRKL2: SOJGE A,BRKL1
JRST RESTR
PASLINS: TDZA B,B ;PASS LINE NOS. SINE COMMENT
NOLINS: MOVEI B,-1 ;INFORM IN THAT IT SHOULD
MOVEM B,LINTBL(CHNL) ; DELETE LINE NOS.
JRST RESTR
BRKLIN: SKIPA B,[-1] ;MARK BREAK ON LINE NOS. FOR THIS TBL
ERMAN: MOVSI B,-1 ;LH NEG SIGNALS ERMAN'S SCHEME
MOVEM B,LINTBL(CHNL)
JRST RESTR
PENDCH: SETOM DSPTBL(CHNL) ;APPEND TO END OF INPUT
JRST RESTR
SKIPCH: TDZA B,B ;CHAR NEVER APPEARS IN INPUT STRING
RETCH: MOVEI B,-1 ;RETAIN FOR NEXT TIME
MOVEM B,DSPTBL(CHNL)
JRST RESTR
;;%##%
UCASE: MOVSS B ;INTO RIGHT HLF
IORM B,BRKCVT(CDB)
JRST RESTR
;;%BG% =A1=
LCASE: MOVSS B
ANDCAM B,BRKCVT(CDB)
JRST RESTR
COMMENT ⊗Setbreak
TBL IS AS IN BREAKSET
BRKSTRNG IS USED FOR ANY "I" OR "X" APPEARING IN MODESTRNG
OMITSTRNG (IF NOT NULL) IS USED TO SET THE "OMIT" SIDE OF THE TABLE
MODESTRNG CAN CONTAIN ANY OF THE VALID BREAKSET "MODE" CHARACTERS
I,X,O,N,R,A,P, or S.
This function is not attainable by the user unless he declares it.
⊗
DSCR SETBREAK(TABLE,"BREAKSTRING","OMITSTRING",MODESTRING");
CAL SAIL
⊗
HERE (SETBREAK)
HRRZ TEMP,-3(SP) ;DO OMIT STRING, IF PRESENT
JUMPE TEMP,NO.O ;NULL STRING DOESN'T COUNT
PUSH P,-1(P) ;TABLE #
PUSH SP,-3(SP) ;OMIT CHARACTERS
PUSH SP,-3(SP)
PUSH P,["O"] ;OMIT!
PUSHJ P,BREAKSET ;DO THAT
NO.O: HRRZS -1(SP) ;COUNT OF # OF COMMANDS
BKSLUP: SOSGE -1(SP) ;DONE?
JRST BKSDUN ; YES
PUSH P,-1(P) ;TABLE #
ILDB TEMP,(SP) ;COMMAND
PUSH P,TEMP
PUSH SP,-5(SP)
PUSH SP,-5(SP) ;STRING TO USE IF NECESSARY
PUSHJ P,BREAKSET
JRST BKSLUP ;DO IT -- AGAIN
BKSDUN: SUB P,X22
SUB SP,[XWD 6,6]
JRST @2(P)
COMMENT ⊗Stdbrk ⊗
DSCR STDBRK(CHANNEL);
CAL SAIL
⊗
HERE (STDBRK)
PUSH P,-1(P) ;CHANNEL
PUSH SP,STDBDV
PUSH SP,STDBDV+1
PUSH P,[14] ;MODE 14
PUSH P,[2] ;INPUT BUFFERS
PUSH P,[0] ;OUTPUT BUFFERS
PUSH P,[0] ;COUNT
PUSH P,[0] ;BRCHAR
PUSH P,[.SKIP.] ;EOF
SETZM .SKIP.
PUSHJ P,OPEN ;OPEN CHANNEL
SKIPE .SKIP. ;ERROR?
ERR <Can't open STDBRK channel>,1,STDEXT
PUSH P,-1(P)
PUSH SP,STDBFL
PUSH SP,STDBFL+1
PUSH P,[.SKIP.]
SETZM .SKIP.
PUSHJ P,LOOKUP
SKIPE .SKIP.
ERR <Can't lookup STDBRK file>,1,STDEXT
PUSH P,-1(P) ;CHANNEL
MOVE USER,GOGTAB
MOVEI X,1 ;ORDINARY USER TABLE #
SKIPE BKTPRV(USER) ;PRIVILEGED?
MOVEI X,0 ;YES
MOVSI TEMP,-1 ;GET BLOCK IF NOT THERE, NO NEED TO INIT
PUSHJ P,BKTCHK ;CHECK OUT SITUATION
JRST STDEXT ;ERROR OF SOME SORE
PUSH P,CDB ;WHERE TO PUT IT
PUSH P,[BRKDUM] ;HOW MUCH TO READ
PUSHJ P,ARRYIN ;READ IN ARRAY
PUSH P,-1(P) ;CHANNEL
PUSH P,[0] ;CLOSE INHIBIT
PUSHJ P,RELEASE ;RELEASE THE FILE
STDEXT:
SUB P,X22 ;CLEAR STACK
JRST @2(P)
NOTENX<
STDBFL:
BKTFIL
STDBDV: =3
POINT 7,[ASCIZ/SYS/]
>;NOTENX
TENX<
STDBFL:
BKTFIL ;DEFINED IN HEAD
STDBDV: =3
POINT 7,[ASCIZ/DSK/],-1
>;TENX
DSCR GETBREAK
returns the number of a free break table
CAL SAIL
⊗
HERE (GETBREAK)
PUSHJ P,SAVE
SKIPN BKTPRV(USER) ;PRIVILEGED?
JRST GTBK03 ;NO
MOVSI D,-4 ;YES, SEARCH ALL 4 GROPS
HRRI D,BKTPTR(USER) ;START AT FIRST GROUP
SETZ A, ;INITIALIZE RESULT
JRST GTBK04
GTBK03: MOVSI D,-3 ;ORDINARY USER, SEARCH LAST 3
HRRI D,BKTPTR+1(USER)
MOVEI A,=18 ;INITIALIZE RESULT
GTBK04:
SETZ C, ;INITIAL RESULT
;;#TP# ! TYPO--USED TO BE SKIPE JFR 10-26-74
GTBK02: SKIPN CDB,(D) ;POINTER TO GROUP OF 18 TABLES
JRST GTBK18 ;NO POINTER, SO WHOLE BLOCK OF 18 FREE
SETCM B,BKJFFO(CDB) ;GET RESERVATION WORD
JUMPE B,GTBK01 ;JUMP IF ALL 18 ARE RESERVED AND INIT'ED
JFFO B,.+1 ;FIND FIRST UNRESERVED TABLE
CAILE C,=17 ;CHECK ONLY RESERVATIONS, NOT INIT'S
JRST GTBK01 ;ALL 18 RESERVED
ADD A,C ;FOUND ONE
ADDI C,1
;;#TP# ! USED TO BE MOVE JFR 10-26-74
GTBKRT: HLLZ B,BRKMSK(C) ;RESERVE THIS TABLE
IORM B,BKJFFO(CDB)
;;#TP# IMPROVE REENTERABILITY
MOVSS B ;BIT INTO RIGHT HALF
ANDCAM B,BKJFFO(CDB) ;NOT INIT'ED
ANDCAM B,BRKCVT(CDB)
ANDCAM B,BRKOMT(CDB)
ADDI C,(CDB) ;RELOCATE 1 TO 18
SETZM LINTBL(C)
SETZM DSPTBL(C)
;;#UO# =E7= JFR 7-28-75 explicitly zero the bits for each character
MOVEI CDB,BRKTBL(CDB) ;FWA OF CHAR TAB
HRLI CDB,-200 ;AOBJN COUNT
HRLI B,(B) ;BIT IN EACH HALF
ANDCAM B,(CDB) ;ZAP!
AOBJN CDB,.-1
;;#UO# ↑
GTBKF2: SUBI A,=17 ;ADJUST FOR INITIAL OFFSET
MOVEM A,RACS+A(USER) ;RESULT
MOVE LPSA,X11
JRST RESTR ;DONE
GTBK01: ADDI A,=18
AOBJN D,GTBK02 ;TRY NEXT GROUP OF 18
GTBKF: MOVNI A,1 ;FAILURE
JRST GTBKF2
;;#TP# REVISED TO USE BKTCHK JFR 10-26-74
;;#%%# BUG FIX JFR 11-13-74
GTBK18: MOVE X,A ;TABLE NUMBER
SUBI X,=17 ;CORRECT
MOVSI TEMP,-1 ;CALL CORGET, NO INIT CHECK
PUSHJ P,BKTCHK
JRST GTBKF ;ERROR RETURN
MOVE C,CHNL
JRST GTBKRT
DSCR RELBREAK
release a break table
CAL SAIL
⊗
HERE (RELBREAK)
PUSHJ P,SAVE
RLBK01: MOVE X,-1(P) ;TABLE #
ADDI X,=17 ;NEG TAB NUMS FOR PRIV USERS CAUSE PROBS
SKIPN BKTPRV(USER) ;PRIVILEGED?
CAIL X,=18 ;LOWEST FOR ORDINARY USER
CAILE X,=71 ;MAX FOR EVERYBODY
JRST RLBKRT ;RELEASE ALWAYS WORKS
IDIVI X,=18
MOVEI A,1(Y) ;A NOW IN RANGE 1 TO 18
ADD X,USER ;RELOCATE GROUP NUMBER
SKIPN B,BKTPTR(X) ;B GETS POINTER TO CORRECT GROUP OF TABLES
JRST RLBKRT ;NON-FATAL ERROR
MOVE TEMP,BRKMSK(A) ;BITS FOR THE TABLE
ANDCAB TEMP,BKJFFO(B) ;UNRESERVE
JUMPN TEMP,RLBKRT ;IF STILL SOME RESERVED
SETZM BKTPTR(X) ;THIS GROUP DEFUNCT
PUSHJ P,CORREL ;RELEASE BLOCK POINTED TO BY B
RLBKRT: MOVE LPSA,X22
JRST RESTR
ENDCOM(BRK)
COMPIL(PRN,<$PRINT,$$PRIN,SETPRINT,GETPRINT,$PINT,$PREL,$PITM,$PSET,$PLST,$PREC,$PSTR>
,<GOGTAB,X22,OUT,OUTSTR,INCHWL,OPEN,GETCHAN,ENTER,.SKIP.,RELEASE,CAT,GETFOR,SETFOR,CATCHR,CVIS,X33,CVS,CVG>
,<STRING PRINTING ROUTINE>)
COMMENT ⊗$print⊗
NOTTTY ←← 400000 ; WANT PRINT OUTPUT TO THE TELETYPE
WNTFLE ←← 200000 ; WANT PRINT OUTPUT TO A FILE
HAVFLE ←← 100000 ; HAVE A FILE FOR OUTPUT
WNTTTY ←← 000000 ; DONT WANT ANY OUTPUT AT ALL
;;%BF% GENERAL STRING OUTPUT ROUTINE
BEGIN STRPRN
;; CONTROL BITS:
UROUTB ←← 400000 ; IF ON THEN JRST (CTRL)
RTNSTR ←← 200000 ; IF ON THEN RETURN(S) ELSE RETURN (NULL)
TTYYES ←← 100000 ; IF ON THEN ALWAYS DO OUTSTR
TTYNOT ←← 040000 ; IF ON THEN DONT OUTSTR UNLESS TTYYES ON
CHNSPC ←← 020000 ; IF ON THEN RH(CTRL) IS CHANNEL (OR JFN)
CHNNOT ←← 010000 ; IF ON THEN DO NOT PUT OUT ANYTHING ON DEFAULT
; CNANNEL
;ALSO THERE IS A WORD PRNINF(USER) THAT CONTAINS SOME "DEFAULTS"
DSCR STRING PROC $PRINT("S",CTRL(0))
DES ROUTINE (ROUGHLY) IS:
BEGIN
I←PRNINF(USER);
IF UROUTB LAND CTRL THEN JRST @RH(CTRL);
IF UROUTB LAND I THEN JRST @RH(I);
$$PRIN: COMMENT THE ENTRY POINT AFTER TRAPPING OUT TO THE USER;
IF (TTYYES LAND CTRL) THEN
OUTSTR(S)
ELSE IF NOT (TTYNOT LAND CTRL) THEN
BEGIN
IF NOT ( (TTYYES!TTYNOT) LAND I) THEN
<SET TTY DEFAULTS>;
IF TTYYES LAND I THEN OUTSTR(S);
END;
IF CHNSPC LAND CTRL THEN OUTF(RH(CTRL),S);
IF NOT (CHNNOT LAND CTRL) THEN
BEGIN
IF NOT ( (CHNNOT!CHNSPC) LAND I) THEN
<SET OUTPUT CHANNEL DEFAULTS>;
IF CHNSPC LAND I THEN OUTF(RH(I),S);
END;
IF RTNSTR LAND CTRL THEN RETURN(S) ELSE RETURN(NULL);
END;
⊗
;; $PRINT ACTUAL CODE
HERE($$PRIN)
TDZA A,A
HERE($PRINT)
MOVEI A,1
MOVE C,-1(P) ;CONTROL BITS
MOVE USER,GOGTAB ;
MOVE B,PRNINF(USER) ;"DEFAULT" BITS
JUMPE A,SPRN.1 ;CAME FROM STRPR1?
TLNE C,UROUTB ;USER ROUTINE?
JRST (C) ;YES
TLNE B,UROUTB ;USER SPEC ONE HERE?
JRST (B) ;YES
SPRN.1: ;STRPR1 COMES IN HERE
TLNE C,TTYYES ;DID HE DEMAND OUTSTR?
JRST .OSTRC ;YES
TLNE C,TTYNOT ;DID HE DEMAND NOT?
JRST SPRN.3 ;YES
TLNN B,TTYNOT!TTYYES ;IS A DEFAULT ESTABLISHED?
PUSHJ P,PDFSET ;NO, DO SO
SPRN.2: TLNN B,TTYYES ;DOES HE WANT IT?
JRST SPRN.3 ;NO
.OSTRC: PUSH SP,-1(SP) ;
PUSH SP,-1(SP) ;
PUSHJ P,OUTSTR ;OUTSTR(S);
SPRN.3: TLNE C,CHNSPC ;SPECIFIED CHANNEL?
JSP D,OUTFN ;OUT(SPEC CHAN,S);
JUMP (C) ;EFFECTIVE ADDRESS IS CHANNEL NO
SPRN.4: TLNE C,CHNNOT ;DID HE SAY THAT IS ALL?
JRST SPRN.5 ;YES
TLNN B,CHNNOT!CHNSPC ;DEFAULTS SET YET?
PUSHJ P,PDFSET ;NOPE DO IT NOW
TLNE B,CHNSPC ;CHANNEL SPECIFIED NOW?
JSP D,OUTFN ;OUTPUT FUNCTION
JUMP (B) ;PASS CHANNEL NUMBER THIS WAY
SPRN.5: TLNN C,RTNSTR ;DID WE WANT S KEPT?
SETZM -1(SP) ;RETURN A NULL INSTEAD OF S
SUB P,X22 ;RETURN
JRST @2(P) ;
OUTFN: MOVEI A,@(D) ;GET CHANNEL NUMBER
PUSH P,A ;PUSH IT
PUSH SP,-1(SP) ;
PUSH SP,-1(SP) ;COPY IS LIKELY FOOLISH
PUSHJ P,OUT ;
JRST 1(D) ;RETURN --RELY ON OUT TO SAVE ACS
PDFSET: PUUO 3,[ASCIZ/
$PRINT called without initialization.
Output to teletype?/]
MOVSI B,TTYYES!CHNNOT ;INITIALLY, ASSUME TTYON
PUSHJ P,$YN
MOVSI B,TTYNOT!CHNNOT ;NO WE DONT
PUUO 3,[ASCIZ/Output to file?/];
PUSHJ P,$YN ;ASK ABOUT IT
JRST OPTSET ;NO
TLC B,CHNNOT!CHNSPC ;YES, WE WILL
DOOP: PUSHJ P,GETCHAN ;CHANNEL NUMBER
HRR B,A ;REMEMBER HERE,TOO
PUSH P,A ;CHANNEL NO
PUSH SP,[3] ;DSK
PUSH SP,[ POINT 7,[ASCIZ/DSK/]]
PUSH P,[0] ;MODE 0
PUSH P,[0] ;NO INPUT
PUSH P,[3] ;3 OUTPUT BUFFERS
PUSH P,[0]
PUSH P,[0]
PUSH P,[.SKIP.] ;EOF VAR
SETZM .SKIP.
OPIT: PUSHJ P,OPEN ;OPEN THE CHANNEL
SKIPE .SKIP.
ERR <OPEN LOST>,1,DOOP
ENIT: PUUO 3,[ASCIZ /File Id=/]
PUSH P,A
PUSHJ P,INCHWL
PUSH P,[.SKIP.]
PUSHJ P,ENTER
SKIPE .SKIP.
JRST ENIT
OPTSET: MOVEM B,PRNINF(USER)
POPJ P,
$YN: PUSHJ P,INCHWL
HRRZ FF,-1(SP);
JUMPE FF,YNRET;
ILDB FF,(SP)
CAIE FF,"Y"
CAIN FF,"y"
AOS (P) ;SKIP RET IF YES
YNRET: SUB SP,X22
POPJ P,
INTERNAL P.FIN
HERE(P.FIN)
BEGIN P.FIN
MOVE USER,GOGTAB
SKIPE B,PRNINF(USER) ;FIRST CLOSE $PRINT FILE
TLNE B,UROUTB
JRST CONTIN
TLNN B,CHNSPC
JRST CONTIN
HRRZS B
PUSH P,B
PUSH P,[0]
PUSHJ P,RELEASE
CONTIN: SKIPE B,PRTINF(USER) ;NOW CLOSE PRINT FILE (WOW!)
TLNN B,HAVFLE
POPJ P,
HRRZS B
PUSH P,B
PUSH P,[0]
PUSHJ P,RELEASE
POPJ P,
BEND P.FIN
BEND STRPRN
DSCR PRINT routines
The SETPRINT and GETPRINT change the output conditions for
the PRINT statement (not CPRINT).
There are three things that may be happening: the user
may or may not have a file open, if so it may or may not be
selected for output; and the user may want output to go to the
terminal. This makes 6 possibilites. Each is represented by
a letter that suggests the meaning.
Bits indicating what is happening are stored in the
left half of user table entry PRTINF; the right half contains
the channel number. Bits indicate if the teletype is NOT selected,
if a file is open, and if the file is selected. These are, symbolically,
WNTTTY, HAVFLE, and WNTFLE. Note that 0 for the entire word means
to just use the teletype for output. This is because the user
table gets zeroed at the start, and so it is given the meaning
of the letter "T".
⊗
HEREFK(SETPRINT,SETPR.)
BEGIN SETPRINT
DEFINE TST(X,Y) <
CAIN D,"X"
MOVSI B,Y
>;
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
MOVE D,-1(P) ;GET ARGUMENT
CAIL D,"a"
CAILE D,"z"
SKIPA
SUBI D,40 ;CONVERT TO UPPER CASE
SETO B,
CAIN D,"C" ;CONSOLE?
JRST [MOVE B,PRTINF(USER)
TLZ B,NOTTTY ;TURN ON TELETYPE
JRST SETRET]
CAIN D,"I" ;IGNORE TERMINAL
JRST [MOVE B,PRTINF(USER)
TLO B,NOTTTY
JRST SETRET]
TST T,WNTTTY
TST F,NOTTTY+WNTFLE+HAVFLE
TST B,WNTTTY+WNTFLE+HAVFLE
TST N,NOTTTY
TST S,NOTTTY+HAVFLE
TST O,WNTTTY+HAVFLE
CAME B,[-1] ;NOT LEGAL OPTION
JRST OKSET
PUUO 1,D ;PRINT A CHAR
ERR <
SETPRINT: Above mode is not legal>,1
MOVSI B,WNTTTY ;FOR DEFAULT ASSUME TTY
JRST SETRET
OKSET:
MOVE D,PRTINF(USER) ;GET OLD VALUE
TLNE D,HAVFLE ;IF HAVE A FILE
TLNE B,HAVFLE ;BUT DONT WANT IT
JRST OKREL
HRRZS D
PUSH P,D
PUSH P,[0] ;CLOSE INHIBIT BITS
PUSHJ P,RELEASE ;RELEASE FILE
JRST SETRET ;AND RETURN
OKREL:
TLNE D,HAVFLE ;IF WE HAVE A FILE
TLNN B,HAVFLE ;AND WANT A FILE
JRST CHKNEED
HRR B,D ;THEN USE IT
JRST SETRET
CHKNEED:
TLNN B,HAVFLE ;WANT A FILE?
JRST SETRET
NOTENX<
HRRZ A,-1(SP)
JUMPG A,.+2 ;HAVE A FILE NAME?
PUSHJ P,GETNAME ;NEED A NAME
GETDSK:
PUSHJ P,GETCHAN ;GET A CHANNEL
CAMN A,[-1]
ERR <SETPRINT: GETCHAN failed>
HRR B,A ;PUT CHANNEL NUMBER IN RH(B)
PUSH P,A ;CHANNEL ARG
PUSH SP,[3]
PUSH SP,[POINT 7,[ASCIZ/DSK/],-1]
PUSH P,[0] ;MODE 0
PUSH P,[0] ;INPUT BUFFERS
PUSH P,[3] ;OUTPUT BUFFERS
PUSH P,[0] ;COUNT WORD
PUSH P,[0] ;BRCHAR
SETZM .SKIP.
PUSH P,[.SKIP.] ;END OF FILE
PUSHJ P,OPEN ;CALL FUNCTION
SKIPE .SKIP. ;A PROBLEM
ERR <SETPRINT: OPEN to the DSK has failed>,1,GETDSK
DOENT: PUSH P,A ;CHANNEL
PUSH SP,-1(SP)
PUSH SP,-1(SP) ;FILE NAME
PUSH P,[.SKIP.]
PUSHJ P,ENTER
SKIPE .SKIP.
JRST [PUUO 3,[ASCIZ/SETPRINT: ENTER failed, type file name
/]
PUSHJ P,GETNAME
JRST DOENT]
JRST SETRET
GETNAME:
PUUO 3,[ASCIZ/
File for PRINT output */]
PUSHJ P,INCHWL
POP SP,-2(SP)
POP SP,-2(SP)
POPJ P,
>;NOTENX
TENX<
EXTERNAL OPENFILE
GETDSK:
PUSH P,B
HRRZ A,-1(SP) ;COUNT OF FILENAME
JUMPG A,.+2 ;CHECK LENGTH
PUUO 3,[ASCIZ/
File for PRINT output */]
PUSH SP,-1(SP)
PUSH SP,-1(SP) ;FILE NAME
PUSH SP,[2]
PUSH SP,[POINT 7,[ASCIZ/WC/],-1]
PUSHJ P,OPENFILE
POP P,B
HRR B,A ;CHANNEL NUMBER
JRST SETRET
>;TENX
SETRET:
MOVEM B,PRTINF(USER)
SUB SP,X22
SUB P,X22
JRST @2(P) ;RETURN
BEND SETPRINT
HEREFK(GETPRINT,GETPR.)
BEGIN GETPRINT
DEFINE TST(X,Y) <
CAIN TEMP,X
MOVEI A,"Y"
>;
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
HLRZ TEMP,PRTINF(USER)
SETO A,
TST WNTTTY,T
TST NOTTTY+WNTFLE+HAVFLE,F
TST WNTFLE+WNTTTY+HAVFLE,B
TST NOTTTY,N
TST NOTTTY+HAVFLE,S
TST HAVFLE+WNTTTY,O
CAMN A,[-1]
ERR <GETPRINT: Illegal mode>,1
POPJ P,
BEND GETPRINT
DSCR $PRSTR -- final string printer
PROCEDURE $PRSTR(STRING S)
Called for either PRINT or CPRINT. Actually does the final output.
CAL PUSHJ (EFFECTIVELY -- ACTUALLY JRST)
ARG STRING ON SP STACK
CHANNEL ON P STACK, -1 FOR TELETYPE
RET THE STRING IS CLEARED FROM THE SP STACK, AND POPJ RETURN
SID NOTHING IS SAFE IF USER ROUTINE CALLED
⊗
$PRSTR:
BEGIN $PRSTR
MOVE USER,GOGTAB
SKIPE TEMP,$$PROU(USER)
JRST WNTOWN ;OWN OUTPUTTING FN.
PRINT1: MOVE TEMP,-1(P) ;GET CHANNEL NUMBER
CAME TEMP,[-1] ;IS IT -1?
JRST WNTCHN ;NO, MUST BE A CHANNEL
SKIPN B,PRTINF(USER) ;SEE IF SETPRINT DONE
JRST OUTSTR ;JUST DEFAULT SETPRINT, THAT'S ALL
TLNE B,NOTTTY ;TELETYPE WANTED?
JRST NOTTY ;NO
PUSH SP,-1(SP)
PUSH SP,-1(SP)
PUSHJ P,OUTSTR
NOTTY: TLNN B,WNTFLE ;FILE WANTED?
JRST [SUB SP,X22
POPJ P,]
HRRZS B
PUSH P,B
JRST WNTCH1
WNTCHN: PUSH P,TEMP ;THE CHANNEL NUMBER
WNTCH1: PUSHJ P,OUT ;STRING ON STACK
POPJ P, ;AND RETURN
WNTOWN: PUSH P,-1(P) ;PUSH CHANNEL NO.
PUSHJ P,(TEMP) ;CALL USER FUNCTION
POPJ P,
BEND $PRSTR
DSCR
These funtions are the top-level functions called from SAIL
for the PRINT and CPRINT statement, for argument types that
are passed on the P stack. The other case, of course, is
a string value, which follows directly.
The calls for the PRINT or CPRINT statement are generated
by first pushing the channel number onto the P stack (-1 for Teletype),
then calling a special routine for each basic syntactic type
encountered. After all calls for the syntactic types, the
channel is removed from the P stack, by a SUB P,[xwd 1,1] instruction
following the calls to the PRINT routines.
CAL PRINT or CPRINT statements
ARG standard SAIL argument passing
CHANNEL is on the P stack, -1 if Teletype
ARG is on the P stack
SID nothing saved
RES nothing
⊗
DEFINE PMAK ! (X,X1,Y,Z) <
HEREFK(X,X1)
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
PUSH P,-1(P) ;PUSH THE ARGUMENT
SKIPE TEMP,Z(USER) ;USER FORMATTING FUNCTION
JRST PRTOWN
PUSHJ P,Y ;NO, CALL STANDARD FORMATTING
JRST PRRET
>;PMAK
;FUNCTION
;CODE COMMON TO ALL PRINTING FUNCTIONS
PRTOWN: PUSHJ P,(TEMP)
PRRET: POP P,-1(P) ;SPLICE ARG OUT FROM STACK
JRST $PRSTR ;AND RETURN
PMAK $PINT,$PINT.,CVS,$$FINT
PMAK $PREL,$PREL.,CVG,$$FREL
PMAK $PITM,$PITM.,PN,$$FITM
PMAK $PSET,$PSET.,PSET1,$$FSET
PMAK $PLST,$PLST.,PLST1,$$FLST
PMAK $PREC,$PREC.,PREC,$$FREC
HEREFK($PSTR,$PSTR.)
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
SKIPE TEMP,$$FSTR(USER) ;SPECIAL STRING FORMATTER?
PUSHJ P,(TEMP) ;YES
JRST $PRSTR ;PRINT AND RETURN
DSCR Utility routines for PRINT statement.
⊗
DSCR PN
STRING PROCEDURE PN(ITEM X)
returns the PNAME of X if one exists, else ITEM!XXX, where XXX is the item number.
Special provision is made for the special items of the SAIL runtime system.
⊗
PN:
BEGIN PN
PUSH P,[0] ;USE STACK FOR VARIABLE
MOVEI A,(P)
PUSH P,-2(P) ;ARGUMENT X NOW
PUSH P,A ;ADDRESS OF FLAG
PUSHJ P,CVIS ;GET STRING ON STRING STACK
SKIPN (P) ;FLAG OK?
JRST RET ;YES OK
SUB SP,X22 ;CLEAR OFF STACK
MOVE A,-2(P) ;GET ITEM NUMBER
CAILE A,3 ;BIGGER THAN BUILTIN RANGE?
JRST USENUM ;YES, USE THE NUMBER
PUSH SP,[3↔6↔6↔12](A)
PUSH SP,[440700,,STRN
170700,,STRN
100700,,STRN+1
440700,,STRN+3](A)
JRST RET
USENUM: PUSH SP,[5]
PUSH SP,[POINT 7,[ASCII/ITEM!/],-1]
PUSH P,-2(P) ;ARGUMENT AGAIN
PUSH P,[-4] ;FOR ACVS
PUSHJ P,ACVS ;GO OFF AND DO IT
PUSHJ P,CAT ;CONCATENATE
RET: SUB P,X33 ;CLEAR OFF EVERYTHING
JRST @2(P) ;AND RETURN
STRN: ASCII/ANYMAINPIBINDITEVENT!TYPE/
BEND PN
DSCR ACVS
STRING PROCEDURE ACVS(INTEGER I,F)
Returns the CVS representation of I by first setting the format
control to F. Used to ensure that there are no leading spaces etc.
⊗
ACVS:
PUSH P,[0]
PUSH P,[0]
MOVEI A,-1(P)
PUSH P,A
MOVEI A,-1(P)
PUSH P,A
PUSHJ P,GETFORMAT ;GET FORMAT INTO STACK LOCATIONS
PUSH P,-3(P) ;F ARGUMENT
PUSH P,[0] ;DOESNT MATTER
PUSHJ P,SETFORMAT
PUSH P,-4(P) ;I ARGUMENT
PUSHJ P,CVS ;GET STRING ONTO STRING STACK
PUSHJ P,SETFORMAT
SUB P,X33 ;CLEAR OFF STACK
JRST @3(P) ;AND RETURN
DSCR GODOWN
STRING PROCEDURE GODOWN(LIST or SET S)
CDR's down S creating a string of the PN's of the items in S.
Does not copy structure etc. Returns the string representing
this list, sans braces, which are added in the calling function.
⊗
GODOWN: BEGIN GODOWN
PUSH SP,[0]
PUSH SP,[0] ;PREPARE FOR STRING
MOVE 1,-1(P)
HRRZ 1,(1)
LOOP: JUMPE 1,DONE
HLRZ 2,(1) ;J ← CAR(I)
HRRZ 1,(1) ;I ← CDR(I)
PUSH P,1 ;SAVE
PUSH P,2 ;SAVE
PUSH P,2 ;ARGUMENT
PUSHJ P,PN ;GET STRING
PUSHJ P,CAT ;HOOK ON STRING
POP P,2 ;RESTORE
POP P,1
JUMPE 1,DONE
PUSH SP,[2]
PUSH SP,[POINT 7,[ASCIZ/, /],-1]
PUSHJ P,CAT
JRST LOOP
DONE: SUB P,X22
JRST @2(P) ;RETURN
BEND GODOWN
DSCR PSET1 -- default formatter for sets
⊗
PSET1: BEGIN PSET1
SKIPN -1(P) ;EMPTY?
JRST RETPHI ;YES
PUSH SP,[1]
PUSH SP,[POINT 7,[BYTE (7) 173,173],-1]
PUSH P,-1(P)
PUSHJ P,GODOWN
PUSHJ P,CAT
PUSH SP,[1]
STANFO <
PUSH SP,[POINT 7,[BYTE (7) 176,176],-1]
>
NOSTANFO <
PUSH SP,[POINT 7,[BYTE (7) 175,175,0,0,0],-1]
>
PUSHJ P,CAT
RET: SUB P,X22
JRST @2(P)
RETPHI: PUSH SP,[3]
PUSH SP,[POINT 7,[ASCIZ/PHI/],-1]
JRST RET
BEND PSET1
DSCR PLST1 -- default formatter for lists
⊗
PLST1: BEGIN PLST1
SKIPN -1(P) ;ANYTHING THERE?
JRST RETNIL ;NO
PUSH SP,[2]
PUSH SP,[POINT 7,[BYTE (7) 173,173],-1]
PUSH P,-1(P)
PUSHJ P,GODOWN
PUSHJ P,CAT
PUSH SP,[2]
STANFO <
PUSH SP,[POINT 7,[BYTE (7) 176,176],-1] ;STANFORD CROCK "ASCII"
>
NOSTANFO <
PUSH SP,[POINT 7,[BYTE (7) 175,175,0,0,0],-1]
>
PUSHJ P,CAT
RET: SUB P,X22
JRST @2(P)
RETNIL: PUSH SP,[3]
PUSH SP,[POINT 7,[ASCIZ/NIL/],-1]
JRST RET
BEND PLST1
DSCR PREC -- default printer for record pointers
⊗
PREC: BEGIN PREC
MOVE 3,-1(P) ;RECORD
JUMPE 3,NULLREC ;SPECIAL FOR NULL!RECORD
MOVE 3,(3) ;POINTER TO CLASS
MOVE 3,5(3) ;POINTER TO WD2 OF STRING
;DESCR FOR CLASS NAME
PUSH SP,-1(3)
PUSH SP,(3) ;STRING TO STACK
PUSH P,["."]
PUSHJ P,CATCHR
PUSH P,-1(P)
PUSH P,[0]
PUSHJ P,ACVS
PUSHJ P,CAT
RECRET: SUB P,X22
JRST @2(P)
NULLREC:
PUSH SP,[=11]
PUSH SP,[POINT 7,[ASCIZ/NULL!RECORD/],-1]
JRST RECRET
BEND PREC
ENDCOM(PRN)
IFE ALWAYS,<
COMPIL(DM5,<P.FIN>,,<DUMMY $PRINT FINISHER>)
↑↑P.FIN:
POPJ P,
ENDCOM(DM5)
>;IFE ALWAYS
IFN ALWAYS,<
BEND STRSER>
SUBTTL IO SERVICE ROUTINES